home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-01 / fixar2.zip / SAVEARR.PRG < prev   
Text File  |  1993-04-02  |  8KB  |  296 lines
  1. // - correction of restoring "nil" contained in a saved array file.
  2. //
  3. //   In FT_RestArr() a problem occured when a NIL had been saved as an
  4. //   element.  Restoring would read the VarType() and then read the size.
  5. //   The problem was that FT_SaveArr() saved only the VarType() for "NIL".
  6. //   This would cause an offset problem for FT_RestArr().
  7. //
  8. //   MARK MITCHELSON - 76515,2207, 03/31/93
  9.  
  10. /*
  11.  * File......: SAVEARR.PRG
  12.  * Author....: David Barrett
  13.  * CIS ID....: 72037,105
  14.  * Date......: $Date:   28 Sep 1992 22:04:18  $
  15.  * Revision..: $Revision:   1.3  $
  16.  * Log file..: $Logfile:   C:/nanfor/src/savearr.prv  $
  17.  *
  18.  * This is an original work by David Barrett and is placed in the
  19.  * public domain.
  20.  *
  21.  * Modification history:
  22.  * ---------------------
  23.  *
  24.  * $Log:   C:/nanfor/src/savearr.prv  $
  25.  *
  26.  *    Rev 1.3   28 Sep 1992 22:04:18   GLENN
  27.  * A few users have reported that these functions do not support
  28.  * multi-dimensional arrays.  Until the bugs are verified and
  29.  * workarounds or re-writes devised, a warning has been placed in the
  30.  * documentation.
  31.  * 
  32.  *    Rev 1.2   15 Aug 1991 23:06:06   GLENN
  33.  * Forest Belt proofread/edited/cleaned up doc
  34.  * 
  35.  *    Rev 1.1   14 Jun 1991 19:52:54   GLENN
  36.  * Minor edit to file header
  37.  * 
  38.  *    Rev 1.0   07 Jun 1991 23:39:38   GLENN
  39.  * Initial revision.
  40.  *
  41.  *
  42.  */
  43.  
  44.  
  45.  
  46. MEMVAR lRet
  47.  
  48. #ifdef FT_TEST              // test program to demonstrate functions
  49.  
  50.  LOCAL  aArray := { {'Invoice 1', CTOD('04/15/91'), 1234.32, .T.},;
  51.                 {'Invoice 2', DATE(), 234.98, .F.},;
  52.                 {'Invoice 3', DATE() + 1, 0, .T.}  }, aSave
  53.  LOCAL nErrorCode := 0
  54.  FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  55.  IF nErrorCode = 0
  56.    CLS
  57.    DispArray(aArray)
  58.    aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  59.    IF nErrorCode = 0
  60.      DispArray(aSave)
  61.    ELSE
  62.       ? 'Error restoring array'
  63.    ENDIF
  64.  ELSE
  65.    ? 'Error writing array'
  66.  ENDIF
  67.  RETURN
  68.  
  69.  FUNCTION DispArray(aTest)
  70.    LOCAL nk
  71.    FOR nk := 1 TO LEN(aTest)
  72.      ? aTest[nk, 1]
  73.      ?? '  '
  74.      ?? DTOC(aTest[nk, 2])
  75.      ?? '  '
  76.      ?? STR(aTest[nk, 3])
  77.      ?? '  '
  78.      ?? IF(aTest[nk, 4], 'true', 'false')
  79.    NEXT
  80.  RETURN Nil
  81. #endif
  82.  
  83.  
  84.  
  85.  
  86. /*  $DOC$
  87.  *  $FUNCNAME$
  88.  *     FT_SAVEARR()
  89.  *  $CATEGORY$
  90.  *     Array
  91.  *  $ONELINER$
  92.  *     Save Clipper array to a disc file.
  93.  *  $SYNTAX$
  94.  *     FT_SAVEARR( <aArray>, <cFileName>, <nErrorCode> ) -> lRet
  95.  *  $ARGUMENTS$
  96.  *     <aArray> is any Clipper array except those containing
  97.  *     compiled code blocks.
  98.  *
  99.  *     <cFileName> is a DOS file name.
  100.  *
  101.  *     <nErrorCode> will return any DOS file error.
  102.  *
  103.  *     All arguments are required.
  104.  *
  105.  *  $RETURNS$
  106.  *     .F. if there was a DOS file error or the array contained
  107.  *     code blocks, otherwise returns .T.
  108.  *  $DESCRIPTION$
  109.  *     FT_SAVEARR() saves any Clipper array, except those
  110.  *     containing compiled code blocks, to a disc file.  The
  111.  *     array can be restored from the disc file using
  112.  *     FT_RESTARR().
  113.  *
  114.  *     [10/1/92 Librarian note:
  115.  *
  116.  *     This function does not appear to work with multi-dimensional
  117.  *     arrays.  If you'd care to modify it to support this feature,
  118.  *     please do and send it to Glenn Scott 71620,1521.]
  119.  *
  120.  *     
  121.  *  $EXAMPLES$
  122.  *    aArray := { {'Invoice 1',CTOD('04/15/91'),1234.32,.T.},;
  123.  *                {'Invoice 2',DATE(),234.98,.F.},;
  124.  *                {'Invoice 3',DATE() + 1,0,.T.}  }
  125.  *    nErrorCode := 0
  126.  *    FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  127.  *    IF nErrorCode = 0
  128.  *      aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  129.  *      IF nErrorCode # 0
  130.  *         ? 'Error restoring array'
  131.  *      ENDIF
  132.  *    ELSE
  133.  *      ? 'Error writing array'
  134.  *    ENDIF
  135.  *
  136.  *  $SEEALSO$
  137.  *     FT_RESTARR()
  138.  *  $END$
  139.  */
  140.  
  141.  
  142. FUNCTION FT_SAVEARR(aArray, cFileName, nErrorCode)
  143.  LOCAL nHandle, lRet
  144.  
  145.  nHandle = FCREATE(cFileName)
  146.  nErrorCode = FError()
  147.  IF nErrorCode = 0
  148.    lRet := _ftsavesub(aArray, nHandle, @nErrorCode)
  149.    FCLOSE(nHandle)
  150.    IF (lRet) .AND. (FERROR() # 0)
  151.       nErrorCode = FERROR()
  152.       lRet = .F.
  153.     ENDIF
  154.  ELSE
  155.    lRet = .F.
  156.  ENDIF
  157.  RETURN lRet
  158.  
  159. STATIC FUNCTION _ftsavesub(xMemVar, nHandle, nErrorCode)
  160.  LOCAL cValType, nLen, cString
  161.  PRIVATE lRet       // accessed in code block
  162.  lRet := .T.
  163.  cValType := ValType(xMemVar)
  164.  IF FWrite(nHandle, cValType, 1) = 1
  165.    DO CASE
  166.      CASE cValType = "A"
  167.        nLen := Len(xMemVar)
  168.        FWrite(nHandle, L2Bin(nLen), 4)
  169.        IF FError() = 0
  170.          AEVAL(xMemVar, {|xMemVar1| lRet := _ftsavesub(xMemVar1, nHandle) } )
  171.        ELSE
  172.          lRet = .F.
  173.        ENDIF
  174.      CASE cValType = "B"
  175.        lRet := .F.
  176.      CASE cValType = "C"
  177.        nLen := Len(xMemVar)
  178.        FWrite(nHandle, L2Bin(nLen), 4)
  179.        FWrite(nHandle, xMemVar)
  180.      CASE cValType = "D"
  181.        nLen := 8
  182.        FWrite(nHandle, L2Bin(nLen), 4)
  183.        FWrite(nHandle, DTOC(xMemVar))
  184.      CASE cValType = "L"
  185.        nLen := 1
  186.        FWrite(nHandle, L2Bin(nLen), 4)
  187.        FWrite(nHandle, IF(xMemVar, "T", "F") )
  188.      CASE cValType = "N"
  189.        cString := STR(xMemVar)
  190.        nLen := LEN(cString)
  191.        FWrite(nHandle, L2Bin(nLen), 4)
  192.        FWrite(nHandle, cString)
  193.    ENDCASE
  194.  ELSE
  195.    lRet = .F.
  196.  ENDIF
  197.  nErrorCode = FError()
  198.  RETURN lRet
  199.  
  200.  
  201. /*  $DOC$
  202.  *  $FUNCNAME$
  203.  *     FT_RESTARR()
  204.  *  $CATEGORY$
  205.  *     Array
  206.  *  $ONELINER$
  207.  *     Restore a Clipper array from a disc file
  208.  *  $SYNTAX$
  209.  *     FT_RESTARR( <cFileName>, <nErrorCode> ) -> aArray
  210.  *  $ARGUMENTS$
  211.  *     <cFileName> is a DOS file name.
  212.  *
  213.  *     <nErrorCode> will return any DOS file error.
  214.  *
  215.  *     All arguments are required.
  216.  *  $RETURNS$
  217.  *     Return an array variable.
  218.  *  $DESCRIPTION$
  219.  *     FT_RESTARR() restores an array which was saved to
  220.  *     a disc file using FT_SAVEARR().
  221.  *
  222.  *     [10/1/92 Librarian note:
  223.  *
  224.  *     This function does not appear to work with multi-dimensional
  225.  *     arrays.  If you'd care to modify it to support this feature,
  226.  *     please do and send it to Glenn Scott 71620,1521.]
  227.  *
  228.  *  $EXAMPLES$
  229.  *    aArray := { {'Invoice 1',CTOD('04/15/91'),1234.32,.T.},;
  230.  *                {'Invoice 2',DATE(),234.98,.F.},;
  231.  *                {'Invoice 3',DATE() + 1,0,.T.}  }
  232.  *    nErrorCode := 0
  233.  *    FT_SAVEARR(aArray,'INVOICE.DAT',@nErrorCode)
  234.  *    IF nErrorCode = 0
  235.  *      aSave := FT_RESTARR('INVOICE.DAT',@nErrorCode)
  236.  *      IF nErrorCode # 0
  237.  *         ? 'Error restoring array'
  238.  *      ENDIF
  239.  *    ELSE
  240.  *      ? 'Error writing array'
  241.  *    ENDIF
  242.  *
  243.  *  $SEEALSO$
  244.  *     FT_SAVEARR()
  245.  *  $END$
  246.  */
  247.  
  248. FUNCTION FT_RESTARR(cFileName, nErrorCode)
  249.  LOCAL nHandle, aArray
  250.  
  251.  nHandle := FOPEN(cFileName)
  252.  nErrorCode := FError()
  253.  IF nErrorCode = 0
  254.   aArray := _ftrestsub(nHandle, @nErrorCode)
  255.   FCLOSE(nHandle)
  256.  ELSE
  257.    aArray := {}
  258.  ENDIF
  259.  RETURN aArray
  260.  
  261. STATIC FUNCTION _ftrestsub(nHandle, nErrorCode)
  262.   LOCAL cValType, nLen, cLenStr, xMemVar, cMemVar, nk
  263.   cValType := ' '
  264.   IF FREAD(nHandle, @cValType, 1) = 1 .and. cValType # 'U'
  265.     cLenStr := SPACE(4)
  266.     IF FREAD(nHandle, @cLenStr, 4) = 4
  267.       nLen = Bin2L(cLenStr)
  268.       DO CASE
  269.         CASE cValType = "A"
  270.           xMemVar := {}
  271.           FOR nk := 1 TO nLen
  272.             AADD(xMemVar, _ftrestsub(nHandle))      // Recursive call
  273.           NEXT
  274.         CASE cValType = "C"
  275.           xMemVar := SPACE(nLen)
  276.           FREAD(nHandle, @xMemVar, nLen)
  277.         CASE cValType = "D"
  278.           cMemVar = SPACE(8)
  279.           FREAD(nHandle, @cMemVar,8)
  280.           xMemVar := CTOD(cMemVar)
  281.         CASE cValType = "L"
  282.           cMemVar := ' '
  283.           FREAD(nHandle, @cMemVar, 1)
  284.           xMemVar := (cMemVar =  "T")
  285.         CASE cValType = "N"
  286.           cMemVar := SPACE(nLen)
  287.           FREAD(nHandle, @cMemVar, nLen)
  288.           xMemVar = VAL(cMemVar)
  289.       ENDCASE
  290.     ENDIF
  291.     nErrorCode := FERROR()
  292.   ENDIF
  293.   nErrorCode := FError()
  294.   RETURN xMemVar
  295.  
  296.